home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / m68lap.t < prev    next >
Text File  |  1988-05-02  |  13KB  |  371 lines
  1. (herald m68lap
  2.         (env tsys))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. (define local-processor
  28.   (lambda ()
  29.     (object nil
  30.       ((processor-type self)     'MC68000)
  31.       ((mc68000-processor? self) '#t)
  32.       ((print-type-string self)  "Processor"))))
  33.  
  34. (define (template-definer-vcell-offset template)
  35.   (let ((template (if (fixnum-equal? (mref-16-u template -2) jump-absolute)
  36.                       (extend-elt template 0)
  37.                       template)))
  38.     (let ((offset (fixnum-ashr (mref-16-u template -12) 3)))
  39.       (if (fx= offset 0) 
  40.           nil
  41.           (fx- offset 1)))))
  42.         
  43. ;;; lap code is of the form (lap free-vars . code)
  44. ;;; lap templates are (lap-template (pointer scratch nargs) . code)
  45.  
  46. (define (invoke-stack-continuation frame vals)
  47.   (lap (return apply)
  48.     (sub .l ($ 2) A1)
  49.     (move .l A1 SP)
  50.     (cmp .l A2 nil-reg)
  51.     (j= no-values)
  52.     (cmp .l (d@r A2 -3) nil-reg)
  53.     (jn= many-values)
  54.     (move .l (d@r A2 1) A1)
  55.     (move .l ($ -2) NARGS)
  56.     (move .l (@r sp) tp)
  57.     (jmp (@r tp))
  58. no-values
  59.     (move .l ($ -1) NARGS)
  60.     (move .l (@r sp) tp)
  61.     (jmp (@r tp))
  62. many-values
  63.     (move .l (d@static P (static 'return)) A1)
  64.     (move .l (d@static P (static 'apply)) P)
  65.     (move .l ($ 3) NARGS)
  66.     (move .l (d@r p -2) tp)
  67.     (jmp (@r tp))))
  68.  
  69. (define (invoke-continuation sp stack vals base-state current-state)
  70.   (lap (rewind-state-and-continue)
  71.     (bset ($ 6) (d@r task task/critical-count))
  72.     (move .l A1 SP)                    ; set new continuation
  73.     (move .l (d@r TASK task/stack) S0) ; limit at stack base
  74.     (add .l ($ 2) A2)                  ; start at first word of stack in heap
  75.     (jbr copy-stack-test)
  76. copy-stack-loop 
  77.     (move .l (@r+ A2) (@r+ A1))
  78. copy-stack-test
  79.     (cmp .l A1 S0)
  80.     (j>= copy-stack-loop)
  81.     (bclr ($ 6) (d@r task task/critical-count))
  82.     (move .l (d@r TASK 12) A1)
  83.     (move .l (d@r TASK 16) A2)
  84.     (move .l (d@static P (static 'rewind-state-and-continue)) P)
  85.     (move .l ($ 4) NARGS)
  86.     (move .l (d@r p -2) tp)
  87.     (jmp (@r tp))))
  88.  
  89.  
  90. ;;; (FIXNUM-HOWLONG n)
  91. ;;;   Returns the number of bits in N's binary representation.
  92. ;;;   Horrible name, after MACLISP function HAULONG.
  93.  
  94. (define (fixnum-howlong num)
  95.   (lap ()
  96.     (move .l a1 s0)
  97.     (lsr  .l ($ 2) s0)             ; S0 hold num
  98.     (move .l ($ 0) s1)             ; S1 holds result
  99.     (move .l s0 s2)                ; S2 used as scratch
  100.     (and  .l ($ #xffff8000) s2)
  101.     (j= howlong1)
  102.     (add  .w ($ 16) s1)
  103.     (swap s0)
  104. howlong1
  105.     (move .w s0 s2)
  106.     (and  .w ($ #x7f80) s2)
  107.     (j= howlong2)
  108.     (add  .w ($ 8) s1)
  109.     (asr  .l ($ 8) s0)
  110. howlong2
  111.     (move .w s0 s2)
  112.     (and  .b ($ #x78) s2)
  113.     (j= howlong3)
  114.     (add  .w ($ 4) s1)
  115.     (asr  .l ($ 4) s0)
  116. howlong3
  117.     (move .w s0 s2)
  118.     (and  .b ($ #x6) s2)
  119.     (j= howlong4)
  120.     (add  .w ($ 2) s1)
  121.     (asr  .l ($ 2) s0)
  122. howlong4
  123.     (move .w s0 s2)
  124.     (and  .b ($ #x1) s2)
  125.     (j= howlong5)
  126.     (add  .w ($ 1) s1)
  127. howlong5
  128.     (asl  .w ($ 2) s1)
  129.     (move .l s1 a1)
  130.     (move .l ($ -2) nargs)
  131.     (move .l (@r sp) tp)
  132.     (jmp (@r tp))))
  133.  
  134.  
  135.               
  136. (define (*set x y)
  137.   (lap ()  
  138.     (move .l A2 (d@r A1 2))
  139.     (tst .b (@r A1))
  140.     (j= foo-set)
  141.     (move .l A1 (d@r TASK task/extra-pointer))
  142.     (jsr (*d@nil slink/set))
  143. foo-set    
  144.     (move .l ($ -2) NARGS)
  145.     (move .l (@r SP) TP)
  146.     (jmp (@r TP))))
  147.  
  148.  
  149. (define (apply-traced-operation proc . args)
  150.   (lap (*traced-op-template*)
  151.     (move .l (d@static P (static '*traced-op-template*)) TP)
  152.     (clr .l S0)
  153.     (jbr entry)))
  154.  
  155. (define (apply proc . args)
  156.  (lap (apply-too-many-args)
  157.   (move .l ($ 1) S0)
  158. entry
  159.   (sub .l ($ 1) NARGS)                   ;; shift proc out
  160.   (move .l P (@-r SP))                   ;; save environment 
  161.   (move .l A1 (@-r SP))                  ;; first arg is proc (save it)
  162.   (cmp .l ($ 1) NARGS)                   ;; no args to proc
  163.   (j= apply-done)
  164.   (sub .l ($ 1) NARGS)
  165.   (cmp .l ($ 1) NARGS)
  166.   (jn= next1)
  167.   (move .l A2 AN)
  168.   (jbr apply-one-arg)
  169. next1
  170.   (cmp .l ($ 2) NARGS)
  171.   (jn= next2)
  172.   (move .l A2 A1)
  173.   (move .l A3 AN)
  174.   (jbr apply-two-args)
  175. next2
  176.   (cmp .l ($ 3) NARGS)
  177.   (jn= next3)
  178.   (move .l A2 A1)
  179.   (move .l A3 A2)
  180.   (move .l (d@r TASK 12) AN)           ;; first argument temp
  181.   (jbr apply-three-args)
  182. next3
  183.   (move .l A2 A1)
  184.   (move .l A3 A2)
  185.   (move .l (d@r TASK 12) A3)            ;; first argument temp
  186.   (move .l NARGS S1)
  187.   (sub .l ($ 4) S1)                     ;; S1 counts sown to 0
  188.   (lea (d@r TASK 16) P)                ;; set up P to point into rest vector
  189.                                        ;; first 3 temps reserved, 1 done already
  190.   (jbr apply-shift-test)
  191. apply-shift-loop-top
  192.   (move .l (@r P) (d@r P -4))
  193.   (sub .l ($ 1) S1)
  194.   (add .l ($ 4) P)
  195. apply-shift-test
  196.   (cmp .l ($ 0) S1)
  197.   (jn= apply-shift-loop-top)
  198.   (move .l (@r P) AN)  
  199.   (sub .l ($ 4) P)
  200.   (jbr apply-spread-loop)
  201. apply-one-arg
  202.   (cmp .l AN nil-reg)   
  203.   (j= apply-done)
  204.   (move .l (d@r AN 1) A1)                    
  205.   (add .l ($ 1) NARGS)
  206.   (move .l (d@r AN -3) AN)                   
  207. apply-two-args
  208.   (cmp .l AN nil-reg)   
  209.   (j= apply-done)
  210.   (move .l (d@r AN 1) A2)                    
  211.   (add .l ($ 1) NARGS)
  212.   (move .l (d@r AN -3) AN)                   
  213. apply-three-args
  214.   (cmp .l AN nil-reg)   
  215.   (j= apply-done)
  216.   (move .l (d@r AN 1) A3)                    
  217.   (add .l ($ 1) NARGS)
  218.   (move .l (d@r AN -3) AN)                   
  219.   (lea (d@r TASK 12) P)
  220. apply-spread-loop              
  221.   (cmp .l AN nil-reg)
  222.   (j= apply-done)
  223.   (move .l (d@r AN 1) (@r P))
  224.   (add .l ($ 1) NARGS)
  225.   (cmp .l ($ (+ *pointer-temps* 1)) NARGS)
  226.   (j> too-many)
  227.   (add .l ($ 4) P)
  228.   (move .l (d@r AN -3) AN)
  229.   (jbr apply-spread-loop)
  230. too-many
  231.   (move .l (@r+ SP) A1)                    ; procedure is argument
  232.   (move .l (@r+ SP) P)
  233.   (move .l ($ 2) NARGS)
  234.   (move .l (d@static P (static 'apply-too-many-args)) P)
  235.   (move .l (d@r p -2) tp)
  236.   (jmp (@r tp))
  237. apply-done                                
  238.   (move .l (@r+ SP) P)                     ; restore procedure
  239.   (add .w ($ 4) SP)                        ; get rid of environment
  240.   (tst .l S0)
  241.   (j= traced)
  242.   (jmp (*d@nil slink/icall))
  243. traced            
  244.   (jmp (@r TP))))
  245.  
  246.  
  247. (define (string-hash string)
  248.   ;; string in A1
  249.   (lap ()
  250.     ;; enter critical gc
  251.     (move .l (d@r A1 offset/string-text) A3);; raw string text in A3
  252.     (add .l (d@r A1 offset/string-base) A3)                              
  253.     (add .l ($ 2) A3)
  254.     (clr .l S1)                             ;; counter in S1
  255. hash                
  256.     (move .l (d@r A1 -2) S0)                ;; length in S0
  257.     (asr .l ($ 8) S0)
  258.     (clr .l S2)                             ;; hash value so far in S2
  259.     (jmp (label hash-test))
  260. hash-loop              
  261.     (rol .l ($ 1) S2)                       ;++ change to 3 later
  262.     (add .b (@r+ A3) S2)
  263. hash-test
  264.     (add .l ($ 1) S1)
  265.     (cmp .l S1 S0)  
  266.     (j>= hash-loop)
  267.     (move .l S2 S1)
  268.     (swap S1) 
  269.     (eor .l S1 S2) 
  270.     (and .l ($ #x7ffffffc) S2)              ;; positive-fixnumize
  271.     (move .l S2 A1)
  272.     ;; exit critical gc                       ;; blat bits 0,1,31
  273.     (move .l ($ -2) NARGS)
  274.     (move .l (@r sp) tp)
  275.     (jmp (@r tp))))
  276.  
  277.             
  278. ;;;  magic frame is next-state
  279. ;;;                 winder
  280. ;;;                 previous-state
  281. ;;;                 unwinder
  282. ;;;                 *magic-frame-template*
  283.  
  284. (define (push-magic-frame unwinder stuff wind)   
  285.  (lap (*magic-frame-template* bind-internal)
  286.   (move .l (d@r TASK task/dynamic-state) AN)
  287.   (move .l nil-reg (@-r SP))                           ; next state
  288.   (move .l A3 (@-r SP))                                ; winder
  289.   (move .l AN (@-r SP))                                ; previous state
  290.   (move .l A1 (@-r SP))                                ; unwinder
  291.   (move .l (d@static P (static '*magic-frame-template*)) (@-r SP))
  292.   (lea (d@r SP 2) A1)                     ; first arg is the magic frame
  293.   (cmp .l AN nil-reg)                     ; is there a previous state?
  294.   (j= magic-frame-exit)
  295.   (move .l A1 (d@r AN 14))                ; set next slot to this magic frame
  296. magic-frame-exit
  297.   (move .l (d@static P (static 'bind-internal)) P)   ; second arg is stuff
  298.   (move .l ($ 3) NARGS)
  299.   (move .l (d@r P -2) tp)
  300.   (jmp (@r tp))))
  301.  
  302. (define (make-structure-template size)
  303.   (lap (*structure-template* *stype-template*)
  304.     (move .l (d@static P (static '*stype-template*)) AN)
  305.     (move .l ($ 36) S1)                            ; 9 slots
  306.     (jsr (*d@nil slink/make-extend))
  307.     (move .w ($ 32) (d@r AN 28))                     ; offset within closure
  308.     (move .b ($ 0) (d@r AN 27))                     ; 0 scratch slots
  309.     (move .l A1 S0)
  310.     (asr .l ($ 2) S0)                              ; pointer slots
  311.     (move .b S0 (d@r AN 26))               
  312.     (move .w ($ #x8000) (d@r AN 30))                ; high bit for template, 0 args
  313.     (move .w ($ M68-JUMP-ABSOLUTE) (d@r AN 32))
  314.     (move .l (d@static P (static '*structure-template*)) (d@r AN 34)) ; auxilliary
  315.     (lea (d@r AN 32) A1)                           ; template
  316.     (move .l AN A2)                                ; stype
  317.     (move .l ($ -3) NARGS)                         ; return two values
  318.     (move .l (@r sp) tp)
  319.     (jmp (@r tp))))
  320.  
  321. ;;; Floating point bit fields.
  322.  
  323. ;;; <n,s> means bit field of length s beginning at bit n of the first
  324. ;;; WORD (not longword)
  325. ;;;                    sign      exponent   MSB       fraction
  326. ;;; Apollo IEEE flonum <15,1>    <4,11>     hidden    <0,4>+next 3 words
  327. ;;; VAX11 flonum (D)   <15,1>    <7,8>      hidden    <0,7>+next 3 words
  328. ;;; Apollo IEEE flonum - binary point follows  hidden MSB, 53 bits of
  329. ;;;     precision, if hidden bit is included
  330. ;;; VAX11 flonum (D)   - binary point precedes hidden MSB, 56 bits of
  331. ;;;     precision, if hidden bit is included 
  332.  
  333. (define-constant %%d-ieee-size 53)
  334. (define-constant %%d-ieee-excess 1023)
  335.  
  336. ;;; <n,s> means bit field of length s beginning at bit n of the first
  337. ;;; WORD (not longword)
  338. ;;;                    sign      exponent   MSB       fraction
  339. ;;; IEEE flonum        <15,1>    <4,11>     hidden    <0,4>+next 3 words
  340. ;;; VAX11 flonum (D)   <15,1>    <7,8>      hidden    <0,7>+next 3 words
  341.  
  342. (define (integer-decode-float x)     ; IEEE version
  343.   (let ((a (mref-16-u x 0)))
  344.     (return (if (fl<= 0.0 x) 1 -1)
  345.             (+ (mref-16-u x 6)
  346.                (%ash (+ (mref-16-u x 4)
  347.                         (%ash (fx+ (mref-16-u x 2)
  348.                                    (fixnum-ashl (fx+ (fixnum-bit-field a 0 4)
  349.                              16)
  350.                                                 16))
  351.                               16))
  352.                      16))
  353.             (fx- (fixnum-bit-field a 4 11) (fx+ 1024 51)))))
  354.  
  355. (define (integer-encode-float sign m e)
  356.   (let ((float (make-flonum)))
  357.     (receive (sign mantissa exponent)
  358.              (normalize-float-parts sign
  359.                                     m
  360.                                     e
  361.                                     %%d-ieee-size 
  362.                                     %%d-ieee-excess 
  363.                                     t)
  364.       (set (mref-16-u float 0) (fx+ (fixnum-ashl sign 15)
  365.                                     (fx+ (fixnum-ashl exponent 4)
  366.                                          (bignum-bit-field mantissa 48 4))))
  367.       (set (mref-16-u float 2) (bignum-bit-field mantissa 32 16)) 
  368.       (set (mref-16-u float 4) (bignum-bit-field mantissa 16 16)) 
  369.       (set (mref-16-u float 6) (bignum-bit-field mantissa 0  16)) 
  370.       float)))
  371.